MacWorld 1999 July/Macworld (1999-07).dmg/Shareware World/Info/For Developers/Mops 3.4.sea/Mops source/PPC source/zPEF

Text File | 1998-09-20 | 28KB | 1,132 lines

(*        =========================================================
                          PEF file generation
        =========================================================

This file handles the writing out of a PEF object file for our compiled
PPC code.

It has more features than cg4, since that only had one job to do - to
write out the initial PPC target image.

*)

forward  write_to_container

0    value    CONTAINER_OFFS
0    value    CHOP_HERE

0    value    MAIN_CODE_SIZE
0    value    SEG_CODE_SIZE
0    value    CODE_OFFS

0    value    MAIN_DATA_SIZE
0    value    SEG_DATA_SIZE
0    value    DATA_OFFS

\ spare_code_size and spare_data_size are in setup

0    value    LDR_SIZE
0    value    LDR_OFFS

false    value    shared_lib?            \ set true if we're generating a shared
                                    \  library

80    constant    INFO_BLOCK_SIZE        \ a block of useful info we put at the
                                    \  start of the code section so our PPC
                                    \  code can pick it up easily.

4    constant    hash_table_power    \ #elements in exports hash table is
                                    \  2**hash_table_power.  Each element is 4 bytes.

4  hash_table_power <<
    constant    hash_table_size


23    constant    #IMPORTED_SYMBOLS
                    \ We define this as a constant since we need it at
                    \  compile time.  In init_import_sym_tbl below, called
                    \  at write_PEF time, we check that the real number of
                    \  imported symbols agrees, and bail out if it doesn't.
                    \  That avoids nasty crashes.

0    value        #EXPORTED_SYMBOLS
0    value        hash_info_len        \ hash table + key table + symbol table

#imported_symbols 4*
    constant    ENTRY_POINT_TOC_OFFSET
                    \ our entry point descriptor comes straight after
                    \  the imported symbols, which are 4 bytes each


    bytestring                ldr_import_sym_tbl
    bytestring                relocs
    bytestring                export_relocs
    bytestring                loader_strings
    bytestring                $cfrg
    bytestring                $threads
16    bytestring_array        export_key_table
16    bytestring_array        exported_symbol_table



\        =============  resource stuff ===============

\ (mainly lifted from InstlMod.txt)


syscall ResError
syscall ChangedResource
syscall AddResource
syscall RemoveResource
syscall CurResFile
syscall UseResFile

: resChk
    ResError  ?dup
    IF  db 3 beep  3 beep  cr
        dup -48 =
        IF    ." You can't save using the same name as the running" cr
            ." application.  Please try again with a different name." cr
        ELSE
            ." Res error# " .  cr
        THEN
        QUIT
    THEN  ;


\ Class RES+ adds methods to Resource to allow various modifications
\ to resources.  We'll put more in as we need them.

:class    RES+    super{ resource }

objPtr    TEMPRES  class_is  res+

:m CHANGED:    get: self  ChangedResource  ;m

:m ADDRES:  { s255 -- }
    get: self
    get: resType  get: ID
    s255  AddResource  resChk  ;m

;class


res+    srcres
res+    dstres

: copyres    \ ( type resID -- )  Copies the resource by copying
            \  the handle's data in memory.  Use this one for resources
            \  currently in use.

    2dup  set: srcRes  set: dstRes
    getnew: srcRes  resChk  srcRes ->: dstRes
    nullOSstr  addRes: dstRes  resChk  ;


\        ===============================================================

\ Before writing the PEF, if we're installing, we have to make sure
\  all needed modules are loaded.

: (LDMOD)  { theCfa dummy \ modObj -- }
    theCfa  mod? NIF  drop  EXIT  THEN
    >obj  -> modObj

    install?: [ modObj ]  IF  load: [ modObj ]  THEN
;

: LOAD_MODS        \ Loads the modules
    false -> instld?        \ so the modules will load!!
    ['] (ldmod)  0 trav
    true -> instld?            \ restore
;


\        ===============================================================


:class  SECTION_HEADER  super{ object }
record
{    var        nameOffset
    var        defaultAddress
    var        totalSize
    var        unpackedSize
    var        packedSize
    var        containerOffset
    ubyte    sectionKind
    ubyte    alignment
    ubyte    shareKind
    ubyte    reservedA
}

:m CLASSINIT:
    -1 put: nameOffset  ;m        \ means no name

:m >SIZES:  ( totalSize initializedSize -- )
    dup put: packedSize put: unpackedSize    \ we don't use PIdata, so
                                            \  these 2 are the same
    put: totalSize
\    get: sectionKind 4 =            \ loader section?
\    IF    clear: execSize
\        clear: initSize
\    THEN
;m

:m >KIND: { kind -- }
    kind  put: sectionKind
    kind 1 =  kind 2 = or
    IF                        \ data or PIdata
            1                \ contextShare
    ELSE    4                \ globalShare
    THEN
    put: shareKind
    4 put: alignment
;m

:m >OFFSET:        put: containerOffset  ;m

:m INIT:    \ ( offset totalSize initializedSize -- )
    >sizes: self  put: containerOffset  ;m

;class

\        ================== loader section stuff ===================

:class  LOADER_HEADER_CLASS  super{ object }
record
{    var        mainSection                \ sect containing main (initial ent pt) desc
                                    \  (we use 1)
    var        mainOffset                \ offs in sect where desc is
    var        initSection                \    ditto for init point desc
    var        initOffset
    var        termSection                \    ditto for term point desc
    var        termOffset
    var        importedLibraryCount
    var        totalImportedSymbolCount
    var        relocSectionCount        \ number of relocation headers
    var        relocInstrOffset
    var        loaderStringsOffset
    var        exportHashOffset
    var        exportHashTablePower
    var        exportedSymbolCount
}

:m INIT:  { relocTblOffs stringsOffs hashSlotTblOffs entrySect -- }
    relocTblOffs    put: relocInstrOffset
    stringsOffs        put: loaderStringsOffset
    hashSlotTblOffs    put: exportHashOffset
    entrySect        put: mainSection

    #imported_symbols        put: totalImportedSymbolCount
    #exported_symbols        put: exportedSymbolCount
    entry_point_toc_offset    put: mainOffset
    shared_lib?
    IF    1 put: initSection
        entry_point_toc_offset    put: initOffset
    THEN
;m

:m CLASSINIT:
    1  put: mainSection            \ change to -1 for shared libs - no main routine
    -1 put: initSection            \ need to use an initialization routine
                                \  for shared libs, so we'll change to 1 here
    -1 put: termSection            \ and maybe a term routine too
    1 put: importedLibraryCount    \ should only be 1 ("InterfaceLib") for Mops PEFs
    1 put: relocSectionCount    \ Only 1 loader relocation header
    hash_table_power  put: exportHashTablePower
;m

;class


: hash_for_PEF  { addr len \ hashValue hash_word hash_index c -- hash_word hash_index }
    0 -> hashValue

    len 0 ?DO
        addr i + c@ -> c
        hashValue 1 <<
        hashValue 16 >> -
        c xor  -> hashValue
    LOOP
    len 16 <<
    hashValue dup 16 >> xor  $ ffff and  or
    -> hash_word

    hash_word
    hash_word hash_table_power >>  xor
    1  hash_table_power << 1-  and  -> hash_index
    hash_word  hash_index
;


:class  EXPORT_HASH_TABLE_CLASS  super{ object }

    hash_table_size        bytes    theTable

:m write:
    addr: theTable  hash_table_size  write_to_container
    16 0 DO
        i select: export_key_table
        all: export_key_table  write_to_container
    LOOP
    16 0 DO
        i select: exported_symbol_table
        all: exported_symbol_table  write_to_container
    LOOP
;m

:m setup:  { \ index chn_cnt -- }

            \ called when there are no more export symbols to be added,
            \  but before we write anything out.  Sets up theTable
            \  according to what we've accumulated in the bytestring_arrays.

    hash_table_size  -> hash_info_len
    0 -> index
    16 0 DO
        i select: export_key_table
        reset: export_key_table
        len: export_key_table  dup ++> hash_info_len
        ?dup
        IF    4/ -> chn_cnt             \ chain count for this hash slot
            chn_cnt 18 <<  index or
            addr: theTable i 4* +  !
            chn_cnt ++> index
        THEN
    LOOP

    16 0 DO
        i select: exported_symbol_table
        reset: exported_symbol_table
        len: exported_symbol_table  ++> hash_info_len
    LOOP
;m

:m add_symbol:  { addr len val \ hash_word hash_index -- }

\ first we do the hash and select the right element in the
\  bytestring_arrays:

    addr len  hash_for_PEF  -> hash_index  -> hash_word

    hash_index  select: exported_symbol_table
    hash_index  select: export_key_table

    hash_word  +L: export_key_table
    pos: loader_strings
    $ 02000000 or                    \ means it's a standard procedure pointer
                                    \  i.e. points to a transfer vector
    +L: exported_symbol_table
    addr len add: loader_strings    \ and we don't need a 0 at the end
    val +L: exported_symbol_table
    1 +W: exported_symbol_table        \ it's in section 1 (data - it's a transfer vect)
;m

:m clear:
    addr: theTable  hash_table_size  erase  ;m

;class


\        ===========================================================


:class  IMP_FILES_SUBSEC_CLASS  super{ object }
record
{    var        fileName
    var        oldDefVersion
    var        currentVersion
    var        numImports
    var        impFirst
    ubyte    initBefore
    ubyte    reservedB
    uint    reservedH
}

:m >numImports:        put: numImports  ;m

;class


:class  PEF_HEADER_CLASS  super{ object }
record
{    var        joy
    var        fileTypeID
    var        architectureID
    var        versionNumber
    var        dateTimeStamp
    var        definVersion
    var        implVersion
    var        currentVersion
    uint    numberSections
    uint    loadableSections
    var        memoryAddress
}

:m CLASSINIT:
    'type    Joy!  put: joy
    'type    peff  put: fileTypeID
    'type    pwpc  put: architectureID
    1  put: versionNumber
    3  put: numberSections
    2  put: loadableSections
;m

:m SETTIMESTAMP:
\    $ 20C @                        \ ### fix after I can handle fetch from a
                                \  literal address!
    0  put: dateTimeStamp  ;m

;class

:class    cfrg_ClASS  super{ object }
record
{    var        res0
    var        res1
    var        cfrgVersion
    var        res2
    var        res3
    var        res4
    var        res5
    var        #fragDescs

\ now the (only) fragment description:
    var        CodeType
    var        UpdateLevel
    var        CurrentVersion
    var        OldestDevVersion
    var        AppStackSize
    uint    AppLibDirectory
    ubyte    TypeOfFragment
    ubyte    LocationOfFragment
    var        OffsetToFragment
    var        LengthOfFragment
    var        res6
    var        res7
}

:m CLASSINIT:
    1 put: cfrgVersion
    1 put: #fragDescs
    'type pwpc  put: codeType
    1 put: TypeOfFragment
    1 put: LocationOfFragment
\ everything else except LenOfInfoRec stays zero.
;m

;class


    cfrg_class                my_cfrg

    PEF_header_class        PEF_header
    section_header            CODE_SECT_HDR
    section_header            DATA_SECT_HDR
    section_header            LOADER_SECT_HDR

    loader_header_class        LOADER_HEADER
    export_hash_table_class    EXPORT_HASH_TABLE

\ we only have one import file - for more, we'd need to have more
\  than one imp_files_subsec_class object.  But note, there's only
\  one import symbol table per PEF.

    imp_files_subsec_class    IMPORT_FILES_SUBSECTION


variable  PAD_BYTES  16 reserve

: ALIGN_IN_CONTAINER  { alignment# \ pad# -- }
    alignment#  container_offs  alignment# 1- and  -
    alignment# 1-  and  -> pad#
    pad#  0EXIT
    pad_bytes pad#  write: ffcb  OK?
    pad# ++> container_offs
;

:f WRITE_TO_CONTAINER  { addr len -- }
    addr len write: ffcb  OK?
    len ++> container_offs
;f


: WRITE_OBJ  { ^obj \ len -- }
    length: [ ^obj ]  -> len
    ^obj len  write_to_container
;


: ADD_EXPORT_SYMBOL  { addr len val \ -- }

    addr len val  add_symbol: export_hash_table
    1 ++> #exported_symbols
;


: (exp)  { theCfa dummy \ addr -- }

    theCfa 2- -> addr
    addr w@ $ BE05 <> ?EXIT
    BEGIN
        -4 ++> addr
        addr w@ $ BF0C =
    UNTIL
    addr 4+ count                \ addr & len of case-sensitive name
    DP  data_start -            \ offset of transfer vector in data section
    add_export_symbol
    theCfa dup
    c@  $ 10 and                \ fp flags?
    IF  6 +  ELSE  2+  THEN        \ get addr of first instruction of defn
    code_start -  ,  0 ,
                \ initial TV has offsets to code to be executed, and data
                \  section (latter offset is zero of course).
    8 ++> main_data_size
    $ 4600 +W: export_relocs    \ RelocTVector8 1 - this will update
                                \  the TV for this entry.

;


: get_exported_symbols
    0 -> #exported_symbols
    shared_lib?  0EXIT            \ if not a shared lib, don't worry about
                                \  exported symbols

\ before we pick up the exported symbols, we need to add a reloc op
\  to set relocAddress to where we are in the data section.  This is
\  the RelocSetPosition op.

    DP data_start -                \ data section offset
    dup 16 >>  $ A000 or  +W: export_relocs  +W: export_relocs

    ['] (exp)  0 trav
;



0    value    IMP_SYM_CNT

: ADD_IMPORT_SYMBOL        \ ( addr len -- )  symbol name is passed in.
    pos: loader_strings
    $ 02000000 or                    \ means it's a standard procedure pointer
                                    \  i.e. points to a transfer vector
    +L: ldr_import_sym_tbl
    add: loader_strings  0 +: loader_strings
    1 ++> imp_sym_cnt  ;


\ Note the symbols we list here are CASE-SENSITIVE!!  The PEF will fail at startup
\  time if something doesn't resolve, and case matters!


: INIT_SYMBOLS
    0 -> imp_sym_cnt
    " InterfaceLib"  add: loader_strings  0 +: loader_strings

    " GetSharedLibrary"            add_import_symbol
    " FindSymbol"                add_import_symbol
    " Debugger"                    add_import_symbol
    " NewHandleClear"            add_import_symbol
    " NewPtrClear"                add_import_symbol
    " MoveHHi"                    add_import_symbol
    " HLock"                    add_import_symbol
    " MakeDataExecutable"        add_import_symbol
    " BlockMove"                add_import_symbol
    " ExitToShell"                add_import_symbol
    " InitGraf"                    add_import_symbol
    " InitFonts"                add_import_symbol
    " InitWindows"                add_import_symbol
    " TEInit"                    add_import_symbol
    " InitMenus"                add_import_symbol
    " InitCursor"                add_import_symbol
    " AEInstallEventHandler"    add_import_symbol
    " GetNewWindow"                add_import_symbol
    " SetPort"                    add_import_symbol
    " NewRgn"                    add_import_symbol
    " TextMode"                    add_import_symbol
    " SysBeep"                    add_import_symbol
    " MaxApplZone"                add_import_symbol

\ add any more we need here.

    imp_sym_cnt #imported_symbols <>  abort" wrong number of imported symbols"
    #imported_symbols >numImports: import_files_subsection

(* *****  testing:
    " jo"    20                    add_export_symbol
    " aardvark"  48                add_export_symbol
    " bloggs"    10                add_export_symbol
    " q"    99                    add_export_symbol
    " smith"    30                add_export_symbol
    " sam"        80                add_export_symbol
    " joe"        90                add_export_symbol
    " somebodyOrOther"    40        add_export_symbol
    " whatever"    50                add_export_symbol
    " youveGotToBeKidding"    60    add_export_symbol
**** *)

    get_exported_symbols
;



: TOC_SIZE    \ ( -- n )    4 bytes for each imported symbol, plus 8 for
                    \    our entry point function descriptor, plus
                    \    32 for saved regs
    entry_point_toc_offset  40 +
;



\ Here we define some words so we can easily make a call to one of these
\  symbols.  We do it here so we can be sure that the TOC offsets are
\  right - these are determined by the above order.


forward (TOC_CALL)

0    value    curr_TOC_offset

: TOC_CALL
    curr_TOC_offset  postpone literal  postpone (TOC_call)
    4 ++> curr_TOC_offset  ;                immediate



: %_GetSharedLibrary
    6 1  TOC_call  ;            immediate

: %_FindSymbol
    4 1  TOC_call  ;            immediate

\ we don't define a %_Debugger - we don't want regs monkeyed with when we
\  call it, so we just hand-wind the calling sequence (at DBGR in cg6).
\ We do, however need the next TOC offset (8) for the symbol "Debugger".

12 -> curr_TOC_offset            \ skip offset 8 (Debugger)

: %_NewHandleClear
    1 1  TOC_call  ;        immediate

: %_NewPtrClear
    1 1  TOC_call  ;        immediate

: %_MoveHHi
    1 0  TOC_call  ;        immediate

: %_HLock
    1 0  TOC_call  ;        immediate

: %_MakeDataExecutable
    2 0  TOC_call  ;        immediate

: %_BlockMove
    3 0  TOC_call  ;        immediate

: %_ExitToShell
    0 0  TOC_call  ;        immediate

: %_InitGraf
    1 0  TOC_call  ;        immediate

: %_InitFonts
    0 0  TOC_call  ;        immediate

: %_InitWindows
    0 0  TOC_call  ;        immediate

: %_TeInit
    0 0  TOC_call  ;        immediate

: %_InitMenus
    0 0  TOC_call  ;        immediate

: %_InitCursor
    0 0  TOC_call  ;        immediate

: %_AEInstallEventHandler
    5 1  TOC_call  ;        immediate

: %_GetNewWindow
    3 1  TOC_call  ;        immediate

: %_SetPort
    1 0  TOC_call  ;        immediate

: %_NewRgn
    0 1  TOC_call  ;        immediate

: %_TextMode
    1 0  TOC_call  ;        immediate

: %_SysBeep
    1 0  TOC_call  ;        immediate


: %_MaxApplZone
    0 0  TOC_call  ;        immediate


(*    INIT_RELOCS adds all the relocation ops to the loader section.  Here's where
    we tell the PEF loader how resolve our imported symbols, etc.
*)

: INIT_RELOCS
    reset: export_relocs
    $ 00010000    +L: relocs            \ these are sect 1 relocs
    len: export_relocs 2/  2+
                +L: relocs            \ there are 2 of them, plus however many
                                    \  export relocs there are
    0            +L: relocs            \ relocs offs = 0

    $ 4A00  #imported_symbols 1- or
                +W: relocs            \ RelocImportRun n - TOC entries for our n
                                    \  imported symbols

    $ 4600        +W: relocs            \ RelocTVector8 1 - this will update our entry
                                    \  point descriptor.  See comment below.
    export_relocs  $add: relocs        \ Add the export relocs, if any
;

(*    Note on how our initial entry point is worked out:

    Our entry point descriptor (2 words) starts out as all zero, because we
    initially erase the TOC area (which starts at data_start).  The reloc
    opcode RelocTVector8 above, adds the value "sectionC" to the first word,
    and "sectionD" to the second, as described in the PEF spec.  These
    two values are initialized to the start of the code and data sections
    respectively at load time, and since we don't alter them with any earlier
    reloc ops, that's what they'll be when RelocTVector8 grabs them.  Thus
    our entry point descriptor will be updated to: ( <start of code>, <start of
    data> ) which means that when we start up, rTOC will be set to the start
    of the data area, and execution will begin at the start of the code
    area.  This is exactly what we want.

    If we later decide to start at some offset into the code area, I presume
    that at PEF time we'll need to put the offset in the word at location
    [ data_start entry_point_TOC_offset + ]
    and this should be appropriately updated by the RelocTVector8 op.
*)


(*    INIT_CODE_SECTION initializes the code section.  code_start and code_size
    are already set up.  We just have to initialize the extra info block.  We
    can put whatever we need in this block.  It's not part of the PEF spec -
    we just use it to pass Mops info to the new app at startup time.  This
    block starts straight after the initial branch, at code_start + 4.  Its
    size is given by the constant info_block_size , so if we add extra fields,
    remember to adjust the constant.  It gets used by GO to allot the space at
    the beginning of the code section before PPC compilation starts.

    Here's the format of the info block - note that this MUST AGREE with
    what setup expects!

ent pt offset      length        what it is

    0            4 bytes        initial branch
    4            4 bytes        code size
    8            4 bytes        data size
    12            4 bytes        displacement from code_start to nuc_code_start
                                (i.e. code generator code size)
    16            4 bytes        displacement from data_start to nuc_data_start
                                (i.e. code generator data size)
    20            32 bytes    initial CONTEXT
    52             4 bytes    flags
    56             4 bytes    #bytes chopped from bottom of seg 8
    60             4 bytes    #bytes chopped from bottom of seg 9
    64             4 bytes    total code size (including spare room)
    68             4 bytes    total data size (including spare room)
    72             8 bytes    spare

        total: 80 bytes.

*)

variable    dummy_len


: FIX_THREAD  { thread# \ thread_addr last_lfa link lfa -- }

    thread# dummy_len c!                \ fake a "length byte" for THREAD
    dummy_len thread  -> thread_addr    \ addr of thread start in CONTEXT

    thread_addr displace  -> lfa        \ addr of first link field in thread,
                                        \  in CONTEXT
    lfa
    code_start 20 + thread# 4* +
    displ!                                \ store in new CONTEXT

    lfa -> last_lfa
    BEGIN
        last_lfa @  -> link                \ save link to see if it changes
        last_lfa displace  -> lfa        \ chain back

        BEGIN                            \ loop over any links below chop_here
            lfa
            IF        lfa chop_here u<
            ELSE    false    \ end inner loop
            THEN
        WHILE
            lfa displace  -> lfa
        REPEAT

        lfa
        IF        lfa last_lfa  displ!
        ELSE    0  last_lfa !
        THEN

        last_lfa @  link <>
        IF
            link +L: $threads  last_lfa +L: $threads
        THEN
        lfa dup -> last_lfa
    NUNTIL
;


: ADD_CONTEXT
    new: $threads                        \ init string to save orig threads
    #threads  FOR  i fix_thread  NEXT
;


: RESTORE_THREADS
    reset: $threads
    BEGIN    len: $threads
    WHILE    nxtL: $threads  ( orig link )  nxtL: $threads ( where it went )  !
    REPEAT
    release: $threads
;


: set_seg_sizes  { \ ^ST len -- }
    0 -> seg_code_size  0 -> seg_data_size
    max_segs 2
    DO    i  8 *  segTable +  -> ^ST
        ^ST c@ 1 and
        IF            \ we need to install this one
            ^ST @ $ 00ffffff and #align4  -> len
            i 1 and
            NIF        \ it's code
                len ++> seg_code_size
            ELSE
                len ++> seg_data_size
            THEN
        THEN
    LOOP
;

: INIT_CODE_SECTION  { \ flags sv_code_start sv_data_start -- }

    0 -> flags  code_start -> chop_here
    instld?
    IF
        1 -> flags
        shared_lib? IF  2 or> flags  THEN
        code_start -> sv_code_start
        nuc_code_start info_block_size -
        dup -> code_start  info_block_size erase
        nuc_code_start -> chop_here
        CDP nuc_code_start - 256 +  -> main_code_size
        code_start sv_code_start -  code_start 56 + !

        data_start -> sv_data_start
        nuc_data_start TOC_size -
        dup -> data_start  TOC_size erase
        DP nuc_data_start - 256 +  -> main_data_size
        data_start sv_data_start -  code_start 60 + !

        set_seg_sizes        \ initialize seg_code_size and seg_data_size

    \ now we must adjust the initial branch and put it at the start
    \  of the (shortened) code section):

        sv_code_start @  $ 03ffffff and
        sv_code_start +  code_start -  $ 48000000 or
        code_start !

    THEN

    main_code_size    code_start  4 + !        \ code size
    main_data_size    code_start  8 + !        \ data size

    main_code_size spare_code_size +  code_start 64 + !
    main_data_size spare_data_size +  code_start 68 + !

    nuc_code_start code_start -
                code_start 12 + !            \ displ to nuc_code_start
    nuc_data_start data_start -
                code_start 16 + !            \ offset to last extern
    flags        code_start 52 + !            \ flags
    add_context                                \ adds 32 bytes
;


: INIT_DATA_SECTION
;        \ data_start and main_data_size are set up already

: INIT_LOADER_SECTION
    clear: export_hash_table
    init_symbols
    setup: export_hash_table
    init_relocs
;


: SET_OFFSETS  { \ relocsOffs stringsOffs hashSlotTblOffs -- }

    0 -> container_offs
    $ 80  -> ldr_offs

    length: loader_header
    #align4  length: import_files_subsection  +
    #align4  size: ldr_import_sym_tbl  +
    #align4  dup 12 +  -> relocsOffs        \ reloc header is always 12 bytes
    size: relocs  +
    #align4  dup -> stringsOffs
    size: loader_strings +
    #align4  dup -> hashSlotTblOffs
    hash_info_len +
    -> ldr_size

    relocsOffs stringsOffs hashSlotTblOffs
    1 ( data section )
    init: loader_header

    ldr_offs ldr_size +  #align16  -> code_offs
    code_offs main_code_size + seg_code_size +  #align16
    -> data_offs

    0 >kind: code_sect_hdr
    1 >kind: data_sect_hdr
    4 >kind: loader_sect_hdr

    code_offs  main_code_size seg_code_size +  dup  init: code_sect_hdr
    data_offs  main_data_size seg_data_size +  dup  init: data_sect_hdr
    ldr_offs  ldr_size dup  init: loader_sect_hdr
;


syscall CreateResFile

\ note: syscall OpenResFile and syscall CloseResFile have already been done,
\  and because they have a different meaning in Mops, we've renamed
\  them to ZpenResFile and ZloseResFile.



: add_resources  { RF_open? installing? \ refNo -- }

\ first we open the resource fork if it's not open already
    RF_open?
    NIF
        getName: ffcb  str255
        CreateResFile  resChk
        buf255  ZpenResFile  -> refNo  resChk
    THEN

\ now we add the 'cfrg' resource:
    new: $cfrg
    my_cfrg  length: my_cfrg  add: $cfrg
    size: $cfrg  getName: ffcb nip +  $ 1D -    \ len of info record section
    +W: $cfrg
    getName: ffcb  dup +c: $cfrg  add: $cfrg
    $cfrg @  dstres !        \ both are subclassed from Handle!
    'type cfrg  0  set: dstres
    nullOSstr  addRes: dstres  resChk

    installing?
    NIF            \ If installing, zInstlMod decides about these
        'type WIND  256  copyRes        \ otherwise we need fWind
        'type BNDL  129  copyRes        \ and the BNDL
        133 128 DO                        \ and the FREFs, icl8's and ICN#s
            'type FREF  i  copyRes        \  (128 - 132)
            'type icl8  i  copyRes
            'type ICN#  i  copyRes
        LOOP
        'type ics8  128  copyRes        \ and ics8 128

    \ and also the new version resource which has a "type" that is the
    \ same as the sig, and ID 0.

        'type Mopp  0  set: dstRes
        50 getstring                \ our version string
        refNo UseResFile            \ need to restore dest res file
        dup 1+ align  new: dstRes
        str255  ptr: dstRes  over  c@ 1+ cMove
        nullOSstr  addRes: dstRes
    THEN

    'type SIZE  -1     copyRes        \ copy SIZE -1

    RF_open?
    NIF
        refNo ZloseResFile
    THEN
;
\ note we mustn't release: $cfrg since the handle now belongs to the
\ Resource Manager!


: write_segs  { 1st_seg# \ ^ST len cnt -- }
    0 -> cnt
    max_segs 1st_seg#
    DO    i  8 *  segTable +  -> ^ST
        ^ST c@ 1 and
        IF            \ we need to install this one
            ^ST @ $ 00ffffff and #align4  -> len
            ^ST 4+ @  len  write_to_container
            1 ++> cnt
        THEN
    2 +LOOP
;


: (wp)  { RF_open? installing? \ svCL svDL -- }
                \ This is the word that writes out the new PEF file.
                \  fFcb must be already set up and open.  If the resource
                \  fork is open, we pass in true.

    installing? -> instld?            \ set global flag in new app
\    shared_lib? if  true -> instld?  then
    code_limit -> svCL  data_limit -> svDL
    CDP -> code_limit  DP  -> data_limit
    code_limit  code_start -  -> main_code_size        \ will get changed if we're installing
    data_limit  data_start -  -> main_data_size        \ ditto

    installing? IF  load_mods  THEN        \ load mods needed in installed app

    cr
    ." code size (hex): "  main_code_size seg_code_size + .h  cr
    ." data size (hex): "  main_data_size seg_data_size + .h  cr

    new: ldr_import_sym_tbl
    new: relocs  new: export_relocs
    new: loader_strings

    classinit: export_key_table
    classinit: exported_symbol_table

    init_code_section            \ must come first as it resets code_start and data_start
                                \  if we're installing
    init_loader_section
    installing? IF  set_seg_sizes  THEN

    init_data_section
\    init_loader_section
    set_offsets
    setTimeStamp: PEF_header

\ write PEF header:
    PEF_header            write_obj
    code_sect_hdr        write_obj
    data_sect_hdr        write_obj
    loader_sect_hdr        write_obj

    pad_bytes 4  write_to_container            \ dummy global symbol table

\ loader section:
    loader_header                write_obj
    import_files_subsection        write_obj
    all: ldr_import_sym_tbl        write_to_container
    all: relocs                    write_to_container    4  align_in_container
    all: loader_strings            write_to_container    4  align_in_container
    write: export_hash_table

\ code section:
    16 align_in_container
    code_start  main_code_size  write_to_container
    installing?
    IF  2 write_segs  THEN                \ add module code segs

\ data section:
    16 align_in_container
    data_start  TOC_size erase            \ TOC area must be initially zero!

    data_start  main_data_size  write_to_container
    installing?
    IF  3 write_segs  THEN                \ add module data segs

    release: ldr_import_sym_tbl
    release: relocs  release: export_relocs
    release: loader_strings

    RF_open? installing? add_resources
    RF_open? NIF  close: ffcb drop  THEN
\    RF_open? add_resources
    restore_threads
    svCL -> code_limit  svDL -> data_limit
;


: CREATE_OUTPF?  ( addr len true | false -- b )
    clear: ffcb
    IF    name: ffcb
    ELSE
        " new PEF file:"  " PowerMops" stdPut: ffcb  NIF  false  EXIT  THEN
    THEN

    open: ffcb NIF  close: ffcb drop  delete: ffcb drop  THEN
    create: ffcb  OK?
    addr: ffcb 18 + @                \ Name pointer - get final app name out of ffcb
    count  32 min  myDocName place
    shared_lib?
    IF        'type shlb  'type cfmg
    ELSE    'type APPL  'type Mopp
    THEN  set: ffcb
    $ 21  addr: ffcb  $ 28 + c!            \ Set Bundle bit
    setFileInfo: ffcb  OK?

    true  ;



: (write_pef)  ( addr len true | false )
        \ If the flag is true, we saved with the passed-in name.
        \ Otherwise we put up a dialog for the output file.

    create_outpf?  0EXIT
    false  false  (wp)
;


: WRITE_PEF        false (write_pef)  ;

: SAVE
    bl word count
    2dup cr cr ." Saved : " type
    true (write_pef)
;

\ shared library testing

: SLTEST
    true -> shared_lib?
    bl word count
    true create_outpf?  0EXIT
    false  true  (wp)
;

:f I/O_err
    ." I/O err " .  cr
    close: ffcb drop
;f

endload

: test
    16 0 DO
        i select: export_key_table
        len: export_key_table
        IF  dump: export_key_table  THEN
    LOOP
    cr
    16 0 DO
        i select: exported_symbol_table
        len: exported_symbol_table
        IF  dump: exported_symbol_table  THEN
    LOOP
    cr cr
    all: $testxx  dump
;